home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / bind.lisp next >
Lisp/Scheme  |  1993-07-17  |  14KB  |  331 lines
  1. ;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:10.; Fonts:CPTFONT -*-
  2. ;;
  3. ;; (C) Copyright 1983 MIT
  4. ;;
  5. ;; Permission to use, copy, modify, distribute, and sell this software
  6. ;; and its documentation for any purpose is hereby granted without fee,
  7. ;; provided that the above copyright notice appear in all copies and that
  8. ;; both that copyright notice and this permission notice appear in
  9. ;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;; advertising or publicity pertaining to distribution of the software
  11. ;; without specific, written prior permission.  M.I.T. makes no
  12. ;; representations about the suitability of this software for any
  13. ;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;
  15. ;;
  16. ;; Deep Binding in Boxer.
  17.  
  18. ;;Dynamic Boxer variables exist in an alist.  You get the value of a
  19. ;;variable by calling the lookup function on it.
  20. ;;
  21.  
  22. ;;If the variable is not found in the alist, then the static variables of the boxes in
  23. ;;the lexical scope of the outermost box being executed are searched.  This searching
  24. ;;happens by asking the DOIT'ed box to look up the variable in its static
  25. ;;alist, and failing finding it there to ask the box it is inside of to do the same,
  26. ;;all the way to the toplevel box.
  27.  
  28. ;;If this search fails, then the lookup function checks the global lispm value cell
  29. ;;of the symbol.  This keeps it from having to search a long ``tail'' of primitive
  30. ;;values.
  31.  
  32. ;;FUNCTION CALLING.
  33. ;;When a function is called, the funcalling mechanism boxer-binds the input variables of the
  34. ;;box being called to be the argument values.  It does this by lisp-binding the big alist
  35. ;;to be a cons of those variable names and values on the front of
  36. ;;the big alist.  This lisp binding goes away when the funcall primitive returns.
  37. ;;
  38. ;;In addition to the input variables, then alist of static variables for the current box
  39. ;;is copied and added to the big alist temporary binding.  It is copied since in our
  40. ;;copy-and-execute model, modifications to the static bindings of a box made while the
  41. ;;box is being are not retained when the box returns.
  42. ;;***this is not yet implemented***
  43. ;;
  44. ;; TELL
  45. ;;TELL binds *BOXER-BINDING-ALIST-ROOT* to NIL (to hide any dynamic bindings)
  46. ;;and binds *BOXER-BINDING-ALIST-ROOT* to box being told.
  47.  
  48. (deff boxer-error 'ferror)
  49.  
  50. (defvar *currently-executing-box* nil
  51.  "BOXER-FUNCALL binds this to the box it is funcalling.")
  52.  
  53. (DEFVAR *BOXER-STATIC-VARIABLES-ROOT* NIL
  54.   "The DOIT key binds the box whose region is being run to be this box.")
  55.  
  56. (DEFMACRO WITH-STATIC-ROOT-BOUND (NEW-ROOT &BODY BODY)
  57.   `(LET ((*BOXER-STATIC-VARIABLES-ROOT* ,NEW-ROOT))
  58.      . ,BODY))
  59.  
  60. (DEFVAR *BOXER-DYNAMIC-VARIABLES-ALIST* NIL)
  61.  
  62. (DEFMACRO WITH-DYNAMIC-VALUES-BOUND (NEW-FRAME &BODY BODY)
  63.   `(LET ((*BOXER-DYNAMIC-VARIABLES-ALIST*
  64.        (ADJOIN-FRAME ,NEW-FRAME *BOXER-DYNAMIC-VARIABLES-ALIST*)))
  65.      . ,BODY))
  66.  
  67. (DEFMACRO WITH-NEW-DYNAMIC-VALUES (NEW-FRAME &BODY BODY)
  68.   `(LET ((*BOXER-DYNAMIC-VARIABLES-ALIST* (ADJOIN-FRAME ,NEW-FRAME NIL)))
  69.      . ,BODY))
  70.  
  71. (defmacro boxer-let* (bindings &body body)
  72.   `(let ((*boxer-binding-alist-root*
  73.        (nconc (mapcar #'(lambda (pair)
  74.                   (cons (car pair)
  75.                     (eval (cadr pair))))
  76.               ',bindings)
  77.           *boxer-binding-alist-root*)))
  78.      .,body))
  79.  
  80. ;;Handling the dynamic environment
  81.  
  82. ;;; this need to flatten out any exporting boxes (SLOW !!!)
  83. ;;; The whole exporting scheme needs to be re-implemented for speed
  84. ;;; and here's an example why....
  85. (DEFUN GET-LOCAL-ENV (BOX)
  86.   (COND ((BOX? BOX)
  87.      (LET* ((BINDINGS (TELL BOX :GET-STATIC-VARIABLES-ALIST))
  88.         (EXPORTS (MAPCAR #'CDR
  89.                  (SUBSET #'(LAMBDA (X) (EQ (CAR X) *EXPORTING-BOX-MARKER*))
  90.                      BINDINGS)))
  91.         (parsed-bindings (with-collection
  92.                    (dolist (b bindings)
  93.                      (unless (eq (car b) *exporting-box-marker*)
  94.                        (collect b))))))
  95.        (LEXPR-FUNCALL #'APPEND parsed-bindings
  96.               (MAP-TELL EXPORTS :GET-STATIC-VARIABLES-ALIST))))
  97.     ((NUMBERP BOX) NIL)
  98.     (T (EVBOX-BINDINGS BOX))))
  99.  
  100. ;;; This is doing EXPLICIT copying of local variables because we are only copying the args and
  101. ;;; NOT the function itself whenever we funcall
  102. (DEFSUBST MAKE-FRAME (BOX &OPTIONAL ARGS)
  103.   (NCONC (NCONS (CONS :FRAME-HEADER BOX))
  104.      (PAIRLIS                ;side effects are safe because of 
  105.        (GET-ARG-NAMES BOX)            ;PAIRLIS
  106.        ARGS)
  107.      (LET ((*EVALUATOR-COPYING-FUNCTION* #'SHALLOW-COPY-FOR-ARGLIST))
  108.        (MAPCAR #'(LAMBDA (X) (CONS (CAR X) (COPY-FOR-EVAL (CDR X))))
  109.            (GET-LOCAL-ENV BOX)))))
  110.  
  111. (DEFSUBST ADJOIN-FRAME (FRAME ENV)
  112.   (APPEND FRAME ENV))
  113.  
  114. ;;Variable lookup function
  115.  
  116. ;; note that box can be an EVbox
  117. (defun lookup-static-variable (variable box)
  118.   (cond ((box? box) (tell box :lookup-static-variable-check-superiors variable))
  119.     ((evbox? box) (assq variable (evbox-bindings box)))
  120.     (t (ferror "Don't know how to look up the variable, ~S, in ~S" variable box))))
  121.  
  122. (DEFUN BOXER-SYMEVAL (VARIABLE)
  123.   (LET ((ENTRY (ASSQ VARIABLE *BOXER-DYNAMIC-VARIABLES-ALIST*)))
  124.     (COND ((NOT (NULL ENTRY)) (CDR ENTRY))
  125.       ((SETQ ENTRY (lookup-static-variable VARIABLE *BOXER-STATIC-VARIABLES-ROOT*))
  126.        (CDR ENTRY))
  127.       ((BOUNDP VARIABLE)            ;global primitive?
  128.        (SYMEVAL VARIABLE))            ;we cache them to avoid a long tail in the alist.
  129.       (T (BOXER-ERROR "The variable ~A is not bound." VARIABLE)))))
  130.  
  131. (DEFUN BOXER-BOUNDP (VARIABLE)
  132.   (or (assq variable *BOXER-DYNAMIC-VARIABLES-ALIST*)
  133.       (LOOKUP-STATIC-VARIABLE variable *BOXER-STATIC-VARIABLES-ROOT*)
  134.       (boundp variable)))            ;global primitive?
  135.  
  136. ;; local lookup function
  137. ;; This takes an alist and looks up the variable.  If there are EXPORTS into the alist, then 
  138. ;; we recurse through the alists of the exports as well
  139. ;; GET-NAMED uses this
  140. ;; Note that this is doing a depth first search of the exports (where we might actually want 
  141. ;; a breadth first search
  142. (DEFUN LOOKUP-LOCAL-VARIABLE (VAR ALIST)
  143.   (LET ((EXPORTS (SUBSET #'(LAMBDA (X) (EQ (CAR X) *EXPORTING-BOX-MARKER*)) ALIST))
  144.     (THING (CDR (ASSQ VAR ALIST))))
  145.     (IF (NOT (NULL THING)) THING
  146.     (DOLIST (EXPORT EXPORTS)
  147.       (LET ((VALUE (LOOKUP-LOCAL-VARIABLE VAR (GET-LOCAL-ENV (CDR EXPORT)))))
  148.         (WHEN (NOT (NULL VALUE)) (RETURN VALUE)))))))
  149.  
  150. ;;; KEEP this around for the parser
  151. ;Variable setting function with searching.  Errors if there is no such variable.
  152. ;Copied from lookup function.
  153. ;This is a low-level function.  Note that sometimes variable "setting"
  154. ;is implemented as box-alteration.
  155. ;(defun boxer-set (variable value)
  156. ;  (let ((entry (assq variable *BOXER-DYNAMIC-VARIABLES-ALIST*)))
  157. ;    (cond ((access-pair? variable)
  158. ;       (let ((*BOXER-STATIC-VARIABLES-ROOT* (boxer-eval (access-pair-superbox variable)))
  159. ;         (*BOXER-DYNAMIC-VARIABLES-ALIST* NIL))
  160. ;         (boxer-set (caar (get-pre-box-rows (access-pair-subbox variable))) value)))
  161. ;      ((not (null entry)) (setf (cdr entry) value))
  162. ;      (t (setq entry (tell *BOXER-STATIC-VARIABLES-ROOT*
  163. ;                   :LOOKUP-STATIC-VARIABLE-CHECK-SUPERIORS
  164. ;                   variable)) 
  165. ;         (if (not (null entry))
  166. ;         (setf (cdr entry) value)
  167. ;         (boxer-error "The variable ~S is not bound." variable))))))
  168.  
  169. ;;; Weird stuff.
  170. ;;; Since there's no consistency about EVBOX objects we'll just add this here.
  171.  
  172. (defun add-static-variable-to-evbox (evbox variable value)
  173.   (if (eq variable *exporting-box-marker*)
  174.       (add-static-variable-to-evbox-internal evbox variable value)
  175.       (let ((entry (assq variable (evbox-bindings evbox))))
  176.     (cond ((null entry)
  177.            (add-static-variable-to-evbox-internal evbox variable value))
  178.           (t (format t "Warning, replacing the old value of ~A" variable)
  179.          (setf (cdr entry) value))))))
  180.  
  181. (defun add-static-variable-to-evbox-internal (evbox variable value)
  182.   (set-evbox-bindings evbox (cons (cons variable value)
  183.                   (evbox-bindings evbox))))
  184. ;;;Lower level methods.
  185.  
  186. ;;;Adds the variable/value pair to the current box's static variable alist.
  187. ;;;Needs to be smart about altering the alist -- or maybe re-calculating it or something?
  188. ;;;This implementation is broken since you won't be able to access the variable after
  189. ;;;you use it.
  190.  
  191. (DEFMETHOD (BOX :SET-STATIC-VARIABLES-ALIST) (NEW-ALIST)
  192.   ;; the file system uses this one.
  193.   (SETQ STATIC-VARIABLES-ALIST NEW-ALIST))
  194.  
  195. (DEFMETHOD (BOX :GET-STATIC-VARIABLES-ALIST) ()
  196.   ;; the file system uses this one too.
  197.   STATIC-VARIABLES-ALIST)
  198.  
  199. (defun boxer-add-static-variable (variable value)
  200.   (tell (or *CURRENTLY-EXECUTING-BOX* *BOXER-STATIC-VARIABLES-ROOT*)
  201.     :ADD-STATIC-VARIABLE-PAIR variable value))
  202.  
  203. (defmethod (box :add-static-variable-pair) (variable value)
  204.   (let ((entry (assq variable static-variables-alist)))
  205.     (WHEN (AND (NOT-NULL (TELL SELF :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY VARIABLE))
  206.            (NEQ (CDR (TELL SELF :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY VARIABLE)) VALUE)
  207.            (NEQ VARIABLE *EXPORTING-BOX-MARKER*))
  208.       ;; The name is already defined in the current box to be something else
  209.       (FORMAT T "Warning, replacing the old value of ~A "VARIABLE))
  210.     (WHEN (SPRITE-BOX? VALUE)
  211.       ;; This is not the correct solution since you might want to keep
  212.       ;; some named sprites private to the graphics box.  This should
  213.       ;; cause the average user to win most of the time though
  214.       (TELL SELF :EXPORT-VARIABLE VARIABLE))
  215.     (COND ((AND (NEQ VARIABLE *EXPORTING-BOX-MARKER*) (not (null entry)))
  216.        (setf (cdr entry) value))
  217.       ((AND (EQ VARIABLE *EXPORTING-BOX-MARKER*) (EQ VALUE (CDR ENTRY))))
  218.       ;;try and cut down on multiple copies of the same box being exported
  219.       (T (push (cons variable value) static-variables-alist)))))
  220.  
  221. (DEFMETHOD (BOX :REMOVE-ALL-STATIC-BINDINGS) (VALUE)
  222.   "Removes all the variables which may be bound to VALUE. "
  223.   (LOOP WITH NEW-EXPORTS = NIL
  224.     FOR PAIR IN STATIC-VARIABLES-ALIST
  225.     UNLESS (EQ (CDR PAIR) VALUE)
  226.     COLLECT PAIR INTO NEW-ALIST
  227.     WHEN (AND (LISTP EXPORTS) (EQ (CDR PAIR) VALUE))
  228.     DO (SETQ NEW-EXPORTS (DELQ (CAR PAIR) EXPORTS))
  229.     FINALLY (SETQ STATIC-VARIABLES-ALIST NEW-ALIST)
  230.             (unless (eq exports  *EXPORT-ALL-VARIABLES-MARKER*)
  231.           (setq EXPORTS NEW-EXPORTS))))
  232.  
  233. (DEFMETHOD (BOX :REMOVE-STATIC-VARIABLE) (VARIABLE)
  234.   "Removes only the single variable binding from the Box's environment. "
  235.   (SETQ STATIC-VARIABLES-ALIST (DELQ (ASSQ VARIABLE STATIC-VARIABLES-ALIST)
  236.                      STATIC-VARIABLES-ALIST))
  237.   (WHEN (AND (NOT-NULL EXPORTS) (NEQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER*))
  238.     (SETQ EXPORTS (DELQ VARIABLE EXPORTS))))
  239.  
  240. (DEFMETHOD (BOX :SET-EXPORTS) (NEW-EXPORTS)
  241.   (SETQ EXPORTS NEW-EXPORTS))
  242.  
  243. (DEFMETHOD (BOX :GET-EXPORTS) ()
  244.   (IF (EQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER*)
  245.       (MAPCAR #'CAR STATIC-VARIABLES-ALIST)
  246.       EXPORTS))
  247.  
  248. (DEFMETHOD (BOX :EXPORT-ALL-VARIABLES) ()
  249.   (WHEN (NULL EXPORTS)
  250.     (TELL (TELL SELF :SUPERIOR-BOX) :ADD-STATIC-VARIABLE-PAIR *EXPORTING-BOX-MARKER* SELF))
  251.     (SETQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER*))
  252.  
  253. (DEFMETHOD (BOX :EXPORT-VARIABLE) (VARIABLE)
  254.   (LET ((VALUE (TELL SELF :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY VARIABLE)))
  255.     (UNLESS (NULL VALUE)
  256.       (WHEN (NULL EXPORTS)
  257.     (TELL (TELL SELF :SUPERIOR-BOX) :ADD-STATIC-VARIABLE-PAIR
  258.           *EXPORTING-BOX-MARKER* SELF))
  259.       (UNLESS (EQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER*)
  260.     (PUSH VARIABLE EXPORTS)))))
  261.  
  262. (DEFMETHOD (BOX :GET-EXPORTING-BOXES) ()
  263.   "Get a list of all the other boxes which export their variable bindings to this one. "
  264.   (MAPCAR #'CDR (SUBSET #'(LAMBDA (X) (EQ (CAR X) *EXPORTING-BOX-MARKER*))
  265.             STATIC-VARIABLES-ALIST)))
  266.  
  267. (DEFMETHOD (BOX :LOOKUP-STATIC-VARIABLE-IN-EXPORTS) (VARIABLE)
  268.   (LET ((EXPORTING-BOXES (TELL SELF :GET-EXPORTING-BOXES))
  269.     (EXPORTING-P (OR (EQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER* ) (MEMQ VARIABLE EXPORTS)))
  270.     (VALUE (ASSQ VARIABLE STATIC-VARIABLES-ALIST)))
  271.     (COND ((AND VALUE EXPORTING-P) VALUE)
  272.       ((AND ;(OR (EQ EXPORTS *EXPORT-ALL-VARIABLES-MARKER* ) (MEMQ VARIABLE EXPORTS))
  273.             ;allow exported variables to automatically be visible anywhere up the chain
  274.             ;of exporting boxes. 
  275.         (NOT-NULL EXPORTING-BOXES))
  276.        (DOLIST (BOX EXPORTING-BOXES)
  277.          (LET ((BINDING-PAIR (TELL BOX :LOOKUP-STATIC-VARIABLE-IN-EXPORTS VARIABLE)))
  278.            (WHEN (NOT-NULL BINDING-PAIR)
  279.          (RETURN BINDING-PAIR))))))))
  280.  
  281. (DEFMETHOD (BOX :LOOKUP-STATIC-VARIABLE-IN-BOX-ONLY) (VARIABLE)
  282.   (LET ((VALUE (ASSQ VARIABLE STATIC-VARIABLES-ALIST))
  283.     (EXPORTING-BOXES (TELL SELF :GET-EXPORTING-BOXES)))
  284.     (COND (VALUE VALUE)
  285.       ((NOT-NULL EXPORTING-BOXES)
  286.        (DOLIST (BOX EXPORTING-BOXES)
  287.          (LET ((BINDING-PAIR (TELL BOX :LOOKUP-STATIC-VARIABLE-IN-EXPORTS VARIABLE)))
  288.            (WHEN (NOT-NULL BINDING-PAIR)
  289.          (RETURN BINDING-PAIR))))))))
  290.  
  291. (DEFMETHOD (BOX :SUPERIOR-BOX-FOR-BINDINGS) ()
  292.   (TELL SELF :SUPERIOR-BOX))
  293.  
  294. (DEFMETHOD (PORT-BOX :SUPERIOR-BOX-FOR-BINDINGS) ()
  295.   (TELL-CHECK-NIL PORTS :SUPERIOR-BOX))
  296.  
  297. (defmethod (box :lookup-static-variable-check-superiors) (variable)
  298.   (let ((value (assq variable static-variables-alist))
  299.     (EXPORTING-BOXES (TELL SELF :GET-EXPORTING-BOXES))
  300.     (superior))
  301.     (cond (value value)
  302.       ;; if we found it, return it
  303.       ((NOT-NULL EXPORTING-BOXES)
  304.        ;; first, look in the boxes which export their variables to this box
  305.        (let ((result 
  306.            (DOLIST (BOX EXPORTING-BOXES)
  307.              (LET ((BINDING-PAIR (TELL BOX
  308.                            :LOOKUP-STATIC-VARIABLE-IN-EXPORTS VARIABLE)))
  309.                (WHEN (NOT-NULL BINDING-PAIR)
  310.              (RETURN BINDING-PAIR))))))
  311.          (if result result (tell (tell self :superior-box-FOR-BINDINGS)
  312.                      :lookup-static-variable-check-superiors variable))))
  313.       ((setq superior (tell self :superior-box-FOR-BINDINGS))
  314.        (tell superior :lookup-static-variable-check-superiors variable))
  315.       (t nil))))
  316.  
  317. (DEFMETHOD (BOX :LOCAL-LIBRARY) ()
  318.   (OR LOCAL-LIBRARY
  319.       (SETQ LOCAL-LIBRARY
  320.         (MAKE-INITIALIZED-BOX ':TYPE ':LL-BOX
  321.                   ':EXPORTS *EXPORT-ALL-VARIABLES-MARKER*))))
  322.  
  323. ;; the file system uses this one
  324. (DEFMETHOD (BOX :SET-LOCAL-LIBRARY) (NEW-LL)
  325.   (SETQ LOCAL-LIBRARY NEW-LL))
  326.  
  327. (DEFMETHOD (BOX :REMOVE-LOCAL-LIBRARY) ()
  328.   (WHEN (NOT-NULL LOCAL-LIBRARY)
  329.     (TELL SELF :REMOVE-ALL-STATIC-BINDINGS LOCAL-LIBRARY)
  330.     (SETQ LOCAL-LIBRARY NIL)))
  331.